The World of Computer Software/The World of Computer Software.iso/faq-s.zip/ABOUT.PAS

Pascal/Delphi Source File | 1991-04-14 | 7.4 KB | 297 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
{$M 65500,0,0 }

unit about;

interface

uses gentypes,configrt,gensubs,subs1,subs2,modem;

procedure aboutthisbbs;

implementation

procedure aboutthisbbs;
var ab:abrec;

  function numabouts:integer;
  begin
    numabouts:=filesize(abfile)
  end;

  procedure seekabfile (n:integer);
  begin
    seek (abfile,n-1)
  end;

  procedure openabfile;
  var n:integer;
  begin
    n:=ioresult;
    assign (abfile,bbsdatadir+'Aboutbbs.dat');
    reset (abfile);
    if ioresult<>0 then begin
      close (abfile);
      n:=ioresult;
      rewrite (abfile)
    end
  end;

  procedure listabouts;
  var cnt:integer;
      b:boolean;
  begin
    b:=true;
    seekabfile (1);
    for cnt:=1 to numabouts do begin
      read (abfile,ab);
      if (ulvl>=ab.level) or issysop then begin
        if b then begin
          writeln;
          writehdr ('Information Files');
          writestr (^R'[Num] [Title]'^M);
          b:=false
        end;
        write (^R'['^S);
        tab (strr(cnt),3);
        write (^R'] ['^S);
        tab (ab.title,60);
        writeln (^R']');
        if break then exit
      end
    end;
    if b then writestr ('Sorry, no information files are available!')
  end;

  function getaboutnum:integer;
  var n:integer;
  begin
    getaboutnum:=0;
    repeat
      writestr ('Information File Number [?/List]:');
      if length(input)=0 then exit;
      if upcase(input[1])='?'
        then listabouts
        else begin
          n:=valu(input);
          if (n<1) or (n>numabouts) then begin
            writestr (^M'Sorry, file number out of range!');
            exit
          end;
          seekabfile (n);
          read (abfile,ab);
          if (ulvl<ab.level) and (not issysop) then begin
            reqlevel (ab.level);
            exit
          end;
          getaboutnum:=n;
          exit
        end
    until hungupon
  end;

  procedure showaboutfile (n:integer);
  begin
    seekabfile (n);
    read (abfile,ab);
    if ulvl<ab.level then begin
      reqlevel (ab.level);
      exit
    end;
    writeln (^M'Title:   '^S,ab.title,
             ^M'Updated: '^S,timestr(ab.when),' at ',datestr(ab.when),^M);
    printfile (ab.fname)
  end;

  procedure makeaboutfile;
  var t:text;
      b:boolean;
  begin
    assign (t,ab.fname);
    rewrite (t);
    writestr (^M'Enter text, /S to save:'^M);
    repeat
      lastprompt:='Continue.'^M;
      wordwrap:=true;
      getstr (1);
      b:=match(input,'/S');
      if not b then writeln (t,input)
    until b;
    textclose (t);
    writestr (^M'File created!');
    ab.when:=now;
    writelog (3,2,ab.fname)
  end;

  procedure addabout;
  begin
    writestr ('Title:');
    if length(input)=0 then exit;
    ab.title:=input;
    writestr ('Level:');
    ab.level:=valu(input);
    writestr ('Path & Filename ['+textfiledir+']:');
    if length(input)=0 then exit;
    if pos('\',input)=0 then input:=textfiledir+input;
    ab.fname:=input;
    if not exist(ab.fname) then begin
      writestr ('File not found!  Enter file now? *');
      if yes then makeaboutfile
    end;
    ab.when:=now;
    seekabfile (numabouts+1);
    write (abfile,ab);
    writestr ('File added.');
    writelog (3,1,ab.title)
  end;

  procedure changeabout;
  var n:integer;

    procedure getstr (prompt:mstr; var ss; len:integer);
    var a:anystr absolute ss;
    begin
      writeln (^B^M'  Current ',prompt,' is: '^S,a);
      buflen:=len;
      writestr ('Enter new '+prompt+':');
      if length(input)>0 then a:=input;
    end;

    procedure getint (prompt:mstr; var i:integer);
    var q:sstr;
        n:integer;
    begin
      str (i,q);
      getstr (prompt,q,5);
      n:=valu (q);
      if n<>0 then i:=n
    end;

  begin
    n:=getaboutnum;
    if n=0 then exit;
    seekabfile (n);
    read (abfile,ab);
    getstr ('title',ab.title,80);
    getint ('level',ab.level);
    getstr ('filename',ab.fname,80);
    if not exist (ab.fname) then write (^B^M,ab.fname,' not found!');
    writestr (^M'Create new file '+ab.fname+'? *');
    if yes then makeaboutfile;
    seekabfile (n);
    write (abfile,ab);
    writelog (3,3,ab.title);
  end;

  procedure deleteabout;
  var cnt,n:integer;
      f:file;
  begin
    n:=getaboutnum;
    if n=0 then exit;
    seekabfile (n);
    read (abfile,ab);
    writestr ('Delete ['^S+ab.title+^P']? *');
    if not yes then exit;
    writestr ('Erase disk file '+ab.fname+'? *');
    if yes then begin
      assign (f,ab.fname);
      erase (f);
      if ioresult<>0
        then writestr ('Couldn''t erase file.')
    end;
    for cnt:=n+1 to numabouts do begin
      seekabfile (cnt);
      read (abfile,ab);
      seekabfile (cnt-1);
      write (abfile,ab)
    end;
    seekabfile (numabouts);
    truncate (abfile);
    writestr (^M'Deleted.');
    writelog (3,4,ab.title)
  end;

  procedure updateabout;
  var n:integer;
  begin
    n:=getaboutnum;
    if n=0 then exit;
    seekabfile (n);
    read (abfile,ab);
    ab.when:=now;
    seekabfile (n);
    write (abfile,ab);
    writeln ('File ',n,' time/date updated.');
    writelog (3,5,ab.title)
  end;

  procedure sysopcommands;
  var q:integer;
  begin
    if not issysop then begin
      reqlevel (sysoplevel);
      exit
    end;
    repeat
      q:=menu ('Info File Sysop','ABOUT','QACDU?');
      case q of
        2:addabout;
        3:changeabout;
        4:deleteabout;
        5:updateabout;
        6:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ About (Info) Sysop Section          ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A]  s');
writeln ('uAdd About File (Info File)     ║HC║ [Cs');
writeln ('u]  Change About File              ║HC║ [s');
writeln ('uD]  Delete About File              ║Hs');
writeln ('uC║ [Q]  Quit                           s');
writeln ('u║HC║ [U]  Update About File       s');
writeln ('u       ║HC║ [?]  View This Menu   s');
writeln ('u              ║HC╚═══════════════════════════════A');
writeln ('C══════╝');
writeln;
pause;
           end;
      end
    until hungupon or (q=1)
  end;

label exit;
var prompt:lstr;
    n:integer;
    k:char;
begin
  openabfile;
  listabouts;
  writehdr ('Information Files');
  repeat
    prompt:=^M'Information File Number [?/List]-[Q/Quit]';
    if issysop then prompt:=prompt+'-[%/Sysop]';
    prompt:=prompt+':';
    writestr (prompt);
    if (length(input)=0) or (upcase(input[1])='Q') then goto exit;
    k:=upcase(input[1]);
    case k of
      'Q':goto exit;
      '%':sysopcommands;
      '?':listabouts;
      else begin
        n:=valu(input);
        if n<>0 then
          if (n<0) or (n>numabouts)
            then writestr ('Out of range!')
            else showaboutfile (n)
      end
    end
  until hungupon;
  exit:
  close (abfile)
end;

begin
end.